home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / pascal4 / pro20 / ftpudemo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-24  |  17.1 KB  |  461 lines
  1. program Fast_Units_Demonstration;
  2. uses dos,crt,fswap,fstack,fbios,fwrite,xwin,file1;
  3. var xx : array[1..10] of longint;
  4.     charre : char;
  5.     orig : Vram_ScrBuf;
  6.     csx,csy : byte;
  7.  
  8. function timenow : longint;
  9. var a,b,c,d : word;
  10. begin
  11.      gettime(a,b,c,d);
  12.      timenow := (((((a*60)+b)*60)+c)*100)+d;
  13. end;
  14.  
  15. procedure dbkp;
  16. var a : word;
  17. begin
  18.      while biostestkey(a) do a := biosreadkey;
  19.      repeat until biostestkey(a);
  20.      while biostestkey(a) do a := biosreadkey;
  21. end;
  22.  
  23. procedure introduction;
  24. begin
  25.      settextattr(7);
  26.      clrscr;
  27.      writeln('You are about to see a demonstration of some of the fastest');
  28.      writeln('utilities written for Turbo Pascal.');
  29.      writeln;
  30.      writeln('If you are not using a CGA or monochrome monitor, you may need');
  31.      writeln('to fiddle with the source code to get the writing routines to');
  32.      writeln('work.  If you have an EGA or VGA or Herculese or "snowy" CGA, you');
  33.      writeln('should skip the FWRITE/XWIN demonstration when asked.');
  34.      writeln;
  35.      writeln;
  36.      writeln('But now, let us proceed with the demonstration.');
  37.      writeln('Press any key to continue...'); dbkp;
  38. end;
  39.  
  40. procedure fswapdemo;
  41. var a,b : byte;
  42.     c,d : word;
  43.     e,f : string;
  44.     r : real;
  45. begin
  46.      a := 2; b := 87;
  47.      e := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  48.      f := '1234567890!@#$%^&*()-=_+[]{};'+#39+'`:"~,./<>?\|';
  49.      clrscr;
  50.      writeln('First, a demonstration of FSWAP.');
  51.      writeln;
  52.      writeln('We will start out with two variables, A and B.  They are both');
  53.      writeln('bytes.  A = ',a,' and B = ',b);
  54.      writeln('Now we'#39'll run qswapb(A,B) and we have');
  55.      qswapb(a,b);
  56.      writeln('A = ',a,' and B = ',b);
  57.      writeln;
  58.      writeln('That was too fast to see, of course.');
  59.      writeln('Well, we'#39'll do it 10,000 times in a row.');
  60.      writeln('Press any key to start...'); dbkp;
  61.      xx[1] := timenow;
  62.      for c := 1 to 10000 do qswapb(a,b);
  63.      xx[2] := timenow;
  64.      r := (xx[2] - xx[1]) / 100;
  65.      writeln('That wasn'#39't very long.  It only took ',r:4:2,' seconds.');
  66.      writeln;
  67.      writeln('FSWAP can also swap words using qswapw.');
  68.      writeln('But the best one is qswapv.  It can swap any two variables of the');
  69.      writeln('same length.  Let'#39's swap two strings 1000 times.');
  70.      writeln('The first string is  ',e);
  71.      writeln('The second string is ',f);
  72.      writeln('Press any key to start...'); dbkp;
  73.      xx[1] := timenow;
  74.      for c := 1 to 1000 do qswapv(e,f,length(e));
  75.      xx[2] := timenow;
  76.      r := (xx[2] - xx[1]) / 100;
  77.      writeln('That took ',r:4:2,' seconds to swap strings ',length(e),' chars long');
  78.      writeln;
  79.      writeln;
  80.      writeln('Now, on to the next unit.');
  81.      writeln('Press any key to continue...'); dbkp;
  82. end;
  83.  
  84. procedure fstackdemo;
  85. var a : array[1..20] of byte;
  86.     c,d,e : word;
  87.     st : string;
  88. label InvalidEnter;
  89. begin
  90.      clrscr; initwstack(a,sizeof(a));
  91.      writeln('FSTACK');
  92.      writeln('Let'#39's try some simple stack routines first.  First we'#39'll');
  93.      writeln('Just push the numbers from 1 to 5 onto the word stack.');
  94.      for c := 1 to 5 do pushw(c);
  95.      writeln('Okay.  Now we'#39'll pop them off again until the stack is empty.');
  96.      writeln('And while were at it, we can write them out.  Press any key to pop.');
  97.      dbkp;
  98.      repeat write(popw,'     '); until wstackempty;
  99.      writeln;
  100.      writeln;
  101.      writeln('Now we can try something a bit harder.  We'#39'll give the byte');
  102.      writeln('stack and the word stack the same buffer.');
  103.      writeln;
  104.      write('Now let me think what to do with that ');
  105.      for c := 1 to (random(4)+3) do
  106.      begin
  107.           delay(500);
  108.           write('. ');
  109.           delay(500);
  110.      end;
  111.      writeln;
  112.      writeln('Okay.  We'#39'll push six words and pop off the twelve bytes that');
  113.      writeln('that makes.  I'#39'll let you enter the values.');
  114.      for c := 1 to 6 do
  115.      begin
  116.           InvalidEnter: write('Enter number #',c,':');
  117.           readln(st);
  118.           val(st,d,e);
  119.           if e <> 0 then goto InvalidEnter;
  120.           pushw(d);
  121.      end;
  122.      writeln;
  123.      writeln('Now that'#39's done.  Now we have to initialize the byte stack');
  124.      writeln('over the word stack and set the byte size to twice the word size');
  125.      writeln('(words are twice as big, after all.).');
  126.      initbstack(a,sizeof(a)); setbstack(wstacksize*2);
  127.      writeln('Okay.  Press any key to do the popping.'); dbkp;
  128.      repeat
  129.            write(popb,'     ');
  130.            if bstacksize = 6 then writeln;
  131.      until bstackempty;
  132.      writeln;
  133.      writeln;
  134.      writeln('Note that the bytes are popped off in reverse of how the words');
  135.      writeln('were pushed on.  (That'#39's how stacks work.)');
  136.      writeln('The stack is still the same as it was before.  If we');
  137.      writeln('wanted, we could do all that popping again.');
  138.      writeln('Only pushing actually changes the stack itself.');
  139.      writeln;
  140.      writeln('By the way, all that was done in an array[1..20] of byte.');
  141.      writeln;
  142.      writeln('You can also switch stacks and save them.  The byte and word');
  143.      writeln('stacks don'#39't have to be on the same array.  Just if you');
  144.      writeln('want.  You can use value typecasing if you want to push');
  145.      writeln('shortints, chars, or integers.  You'#39'll have to push longer');
  146.      writeln('things in pieces.');
  147.      writeln;
  148.      writeln('Just a note.  You don'#39't have to use arrays.  You can use strings');
  149.      writeln('records, arrays, sets, or even longints for your stack.');
  150.      writeln;
  151.      writeln('Now on to FBIOS...');
  152.      writeln('Press any key to continue...'); dbkp;
  153. end;
  154.  
  155. procedure fbiosdemo;
  156. var a,b,c,d : word;
  157.     e,f,g,h : byte;
  158.     ch : char;
  159. label NoPrint;
  160. begin
  161.      clrscr;
  162.      biosgetcur(e,f);
  163.      writeln('FBIOS');
  164.      writeln('Right now, your cursor starts on line ',e,' and ends on line ',f);
  165.      writeln('Let'#39's change it.');
  166.      if e = 0 then
  167.      begin
  168.           if vid_mem_start = $B000 then
  169.           begin
  170.                g := 12; h := 13;
  171.                bioscurshape(g,h);
  172.           end
  173.           else
  174.           begin
  175.                g := 6; h := 7;
  176.                bioscurshape(g,h);
  177.           end;
  178.           writeln('Now the cursor is an underline.');
  179.           writeln('Press any key to continue the demo...'); dbkp;
  180.      end
  181.      else
  182.      begin
  183.           if vid_mem_start = $B000 then
  184.           begin
  185.                g := 0; h := 13;
  186.                bioscurshape(g,h);
  187.           end
  188.           else
  189.           begin
  190.                g := 0; h := 7;
  191.                bioscurshape(g,h);
  192.           end;
  193.           writeln('Now the cursor is a block.');
  194.           writeln('Press any key to continue the demo...'); dbkp;
  195.      end;
  196.      writeln('But I don'#39't want to do any damage to your cursor, so');
  197.      writeln('I'#39'll nicely set it back to what it was before.');
  198.      bioscurshape(e,f);
  199.      writeln('Press any key to continue the demo...'); dbkp;
  200.      writeln;
  201.      writeln('We still have printing left to do.  When you have your printer');
  202.      writeln('ready to print, press any key.  If you don'#39't have a printer');
  203.      writeln('or you don'#39't want to do any printing, press ESC.');
  204.      if keypressed then repeat ch := readkey until not keypressed;
  205.      repeat until keypressed;
  206.      repeat
  207.            ch := readkey;
  208.            if ch = #27 then goto NoPrint;
  209.      until not keypressed;
  210.      writeln('Okay.  Now I'#39'm going to print the screen.  Here we go...');
  211.      biosprintscr;
  212.      clrscr;
  213.      writeln('There.  That works just like a Shift-PrtSc does.');
  214.      writeln('FBIOS also has routines to send data to the printer one');
  215.      writeln('character at a time, which speeds up graphics printing.');
  216.      writeln('Press any key to continue the demo...'); dbkp;
  217.      NoPrint: writeln;
  218.      writeln('Now what character is at 1,1 on the screen?');
  219.      writeln('Hmmm...');
  220.      writeln('There'#39's a FBIOS routine for that too.');
  221.      writeln('First we have to put the cursor there.  Then we'#39'll read the');
  222.      writeln('character.'); biosgetxy(e,f);
  223.      biosgotoxy(1,1); biosgetchar(ch,g);
  224.      biosgotoxy(e,f);
  225.      writeln('We did that.  By the way, I also used BiosGetXY and BiosGotoXY to');
  226.      writeln('go to 1,1 on the screen and return to here.');
  227.      writeln('What character did we get?');
  228.      writeln('Here it is, on the next line.');
  229.      bioschar(ch,g); writeln;
  230.      writeln('Press any key to continue the demo...'); dbkp;
  231.      clrscr;
  232.      writeln('That'#39's not everything.  But that'#39's enough for now.');
  233.      writeln;
  234.      writeln('By the way, all of the "Press any key to continue" or similar');
  235.      writeln('wait-for-a-key things are using BiosTestKey and BiosReadKey.');
  236.      writeln;
  237.      writeln('Press any key to continue...'); dbkp;
  238. end;
  239.  
  240. procedure fwritedemo;
  241. var scrn : ^vram_scrbuf;
  242.     a,b,c,d,e : byte;
  243.     ch : char;
  244.     r : real;
  245. begin
  246.      clrvram(112); settextattr(7); gotoxy(1,1);
  247.      writeln('FWRITE');
  248.      writeln('I just want to let you know that the text in this demo');
  249.      writeln('is still being written with WriteLn.');
  250.      writeln;
  251.      writeln('This window was cleared using a FWRITE procedure.');
  252.      writeln;
  253.      writeln('How long does it take to write 2000 characters in random locations');
  254.      writeln('on the screen using write?');
  255.      writeln;
  256.      writeln('Press any key to continue...'); dbkp;
  257.      xx[1] := timenow;
  258.      for a := 1 to 20 do
  259.      begin
  260.           for b := 1 to 100 do
  261.           begin
  262.                ch := chr(random(240) + 16);
  263.                c := random(24)+1;
  264.                d := random(79)+1;
  265.                gotoxy(d,c);
  266.                write(ch);
  267.           end;
  268.      end;
  269.      xx[2] := timenow;
  270.      xx[3] := xx[2] - xx[1];
  271.      r := xx[3] / 100;
  272.      gotoxy(1,1); settextattr(112);
  273.      writeln('That was write.  It took ',r:4:2,' seconds.');
  274.      writeln('Now we'#39'll use routines from FBIOS.');
  275.      writeln;
  276.      writeln('Press any key to continue...'); dbkp;
  277.      xx[1] := timenow;
  278.      for a := 1 to 20 do
  279.      begin
  280.           for b := 1 to 100 do
  281.           begin
  282.                ch := chr(random(240)+16); c := random(24)+1;
  283.                d := random(79)+1; biosgotoxy(d,c); bioschar(ch,7);
  284.           end;
  285.      end;
  286.      xx[2] := timenow; xx[4] := xx[2] - xx[1]; r := xx[4] / 100;
  287.      gotoxy(1,1); settextattr(112);
  288.      writeln('That was BiosChar.  It took ',r:4:2,' seconds.');
  289.      writeln('Now it is FWRITE'#39's turn with VramCh.');
  290.      writeln; writeln('Press any key to continue...'); dbkp;
  291.      xx[1] := timenow;
  292.      for a := 1 to 20 do for b := 1 to 100 do
  293.      begin
  294.           ch := chr(random(240)+16); c := random(24)+1; d := random(79)+1;
  295.           vramch(d,c,ch,7);
  296.      end;
  297.      xx[2] := timenow; xx[5] := xx[2] - xx[1]; r := xx[5] / 100;
  298.      gotoxy(1,1); settextattr(112);
  299.      writeln('That was VramCh.  And it took only ',r:4:2,' seconds.');
  300.      writeln('Oops!  I forgot; the routines that create the random locations');
  301.      writeln('take some time themselves.  How can I fix that?');
  302.      writeln;
  303.      writeln('I guess I run the random routines by themselves and subtract');
  304.      writeln('that time from the Write, BiosChar, and VramCh'#39's time.');
  305.      writeln('It will just take a second to run the randoms.  Press any key.'); dbkp;
  306.      xx[1] := timenow;
  307.      for a := 1 to 20 do for b := 1 to 100 do
  308.      begin
  309.           ch := chr(random(240)+16); c := random(24)+1; d := random(79)+1;
  310.      end;
  311.      xx[2] := timenow;
  312.      xx[6] := xx[2] - xx[1]; xx[3] := xx[3] - xx[6];
  313.      xx[4] := xx[4] - xx[6]; xx[5] := xx[5] - xx[6];
  314.      writeln;
  315.      writeln('Now we'#39've got the real times.');
  316.      r := xx[3] / 100;
  317.      writeln('     Write ...... ',r:4:2); r := xx[4] / 100;
  318.      writeln('     BiosChar ... ',r:4:2); r := xx[5] / 100;
  319.      writeln('     VramCh ..... ',r:4:2);
  320.      writeln;
  321.      writeln('Press any key to continue this demo...'); dbkp;
  322.      clrvram(7); settextattr(7); gotoxy(1,1);
  323.      writeln('Okay.  When this program started running, it saved the');
  324.      writeln('original screen.  Let'#39's take a peek at it.');
  325.      writeln('Press any key to see the screen, and press any key to return.');
  326.      dbkp; new(scrn);
  327.      getxy(a,b); getvramsec(scrn^,1,1,80,25,1,1);
  328.      putvramsec(orig,1,1,80,25,1,1); gotoxy(csx,csy); dbkp;
  329.      putvramsec(scrn^,1,1,80,25,1,1);
  330.      gotoxy(a,b);
  331.      dispose(scrn);
  332.      writeln('Now we'#39're back.  When you leave this demo, the screen will be');
  333.      writeln('restored.');
  334.      writeln;
  335.      writeln('You can use FWRITE'#39's routines to switch the I/O done from the');
  336.      writeln('screen to a large enough buffer.');
  337.      writeln;
  338.      writeln('FWRITE'#39's routines include procedures and functions that:');
  339.      writeln('   Copy one place on the screen to another');
  340.      writeln('   Repeat a character a given number of times');
  341.      writeln('   Write out strings');
  342.      writeln('   Scroll the screen up or down');
  343.      writeln('   Get characters, lines, or whole sections of the screen');
  344.      writeln('And others!');
  345.      writeln;
  346.      writeln('Press any key to continue...'); dbkp;
  347. end;
  348.  
  349. procedure xwindemo;
  350. var singl,doubl,trpl : string;
  351. begin
  352.      settextattr(7); clrscr; singl := bordermaker(218,191,192,217,196,179);
  353.      doubl := bordermaker(201,187,200,188,205,186);
  354.      trpl := bordermaker(3,4,5,6,29,18);
  355.      writeln('Windows are fun.  Let'#39's make one now and do our writing in');
  356.      writeln('that.');
  357.      writeln('Press any key to create the window...'); dbkp;
  358.      createwindow(1,5,3,75,22,7,112,'The first window','/\\/-!');
  359.      writeln('Press any key to continue this demo...'); dbkp;
  360.      writeln;
  361.      writeln('This window is a XWIN window.  It uses Turbo Pascal'#39's');
  362.      writeln('Window procedure so that writeln will work in it.  It doesn'#39't');
  363.      writeln('affect any BIOS routines or FWRITE.  It is best not to use');
  364.      writeln('TP'#39's Window procedure if you use XWIN.');
  365.      writeln;
  366.      writeln('XWIN is very fast.  Press any key to create four windows...'); dbkp;
  367.      createwindow(2,1,1,60,15,7,7,'Window #1',singl);
  368.      writeln('Press any key for next...'); dbkp;
  369.      createwindow(3,21,1,80,15,7,112,'Window #2',doubl);
  370.      writeln('Press any key for next...'); dbkp;
  371.      createwindow(4,1,11,60,25,112,7,'Window #3','/\\/-|');
  372.      writeln('Press any key for next...'); dbkp;
  373.      createwindow(5,21,11,80,25,112,112,'Window #4',trpl);
  374.      writeln('Now we have four windows.  We can call any one we want.');
  375.      writeln('But now, we'#39'll call the big window back again.');
  376.      writeln('Press any key to get the big window...'); dbkp;
  377.      gotowindow(1);
  378.      writeln;
  379.      writeln('Now we'#39'll call each little window.');
  380.      writeln('Press any key to call the windows...'); dbkp;
  381.      gotowindow(5);
  382.      gotowindow(4);
  383.      gotowindow(3);
  384.      gotowindow(2);
  385.      writeln;
  386.      writeln('That'#39's enough for this demo.');
  387.      writeln('Press any key to pop the windows and go on to FILE1...');
  388.      dbkp; popwindow; popwindow; popwindow; popwindow; popwindow;
  389.      window(1,1,80,25);
  390. end;
  391.  
  392. procedure file1demo;
  393. var b : boolean;
  394.     fname : pathstr;
  395.     r : byte;
  396. begin
  397.      fname := 'READ.ME';
  398.      settextattr(7); clrscr;
  399.      writeln('Is READ.ME here?');
  400.      b := existfile('READ.ME');
  401.      if b = false then
  402.      begin
  403.           writeln('Well, I couldn'#39't find READ.ME.');
  404.           write('Enter the name and path of the file you would like typed:');
  405.           readln(fname);
  406.           b := existfile(fname);
  407.      end;
  408.      if b = false then
  409.      begin
  410.           writeln('Oh dear.  The file you entered wasn'#39't there as you entered it,');
  411.           writeln('And neither was READ.ME.');
  412.           writeln;
  413.      end
  414.      else
  415.      begin
  416.           writeln('Press any key to stop the typing, or ESC to end.');
  417.           writeln('The typing will be in reverse video.');
  418.           settextattr(112);
  419.           typefile(fname,r);
  420.           settextattr(7);
  421.           if r <> 0 then writeln('Oops!  There was an error in typing!')
  422.           else
  423.           begin
  424.               writeln;
  425.               writeln('Okay, we'#39're done.');
  426.           end;
  427.           writeln('Press any key to continue...'); dbkp;
  428.      end;
  429.      writeln;
  430.      writeln('Well, that'#39's the end of this demo.');
  431.      writeln;
  432.      writeln('If you haven'#39't already, be sure to read READ.ME');
  433.      writeln('at least a bit carefully.');
  434.      writeln;
  435.      writeln('But now, it'#39's time to go.');
  436.      writeln('Press any key to end...'); dbkp;
  437. end;
  438.  
  439.  
  440. begin
  441.      getxy(csx,csy);
  442.      getvramsec(orig,1,1,80,25,1,1);
  443.      randomize;
  444.      introduction;
  445.      fswapdemo;
  446.      fstackdemo;
  447.      fbiosdemo;
  448.      clrscr;
  449.      write('Do you want to do the FWRITE and XWIN demonstration? (Y/N) ');
  450.      repeat
  451.            charre := readkey;
  452.            charre := upcase(charre);
  453.      until (charre in ['N','Y']);
  454.      if charre <> 'N' then
  455.      begin
  456.           fwritedemo;
  457.           xwindemo;
  458.      end;
  459.      file1demo;
  460.      putvramsec(orig,1,1,80,25,1,1); gotoxy(csx,csy);
  461. end.